home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / scsh / jcontrol2.scm < prev    next >
Text File  |  1995-10-26  |  5KB  |  168 lines
  1. ;;; Copyright (c) 1993 by Olin Shivers.
  2. ;;; Job control code.
  3.  
  4. (foreign-source
  5.   "#include <sys/signal.h>"
  6.   "#include <sys/types.h>"
  7.   "#include <unistd.h>"
  8.   ""
  9.   "extern int errno;"
  10.   ""
  11.   "#define errno_or_false(x) (((x) == -1) ? ENTER_FIXNUM(errno) : SCHFALSE)"
  12.   "" "")
  13.  
  14. ;;; Fork off a process that runs in its own process group. The process is
  15. ;;; placed in its own process group before the process's actual work code is
  16. ;;; executed. We block ^Z's until we've got the child into its own proc group.
  17.  
  18. (define (fork-job . maybe-thunk)
  19.   (flush-all-ports)
  20.   ((with-blocked-interrupts (bitwise-ior (blocked-interrupts)    ; Block ^Z.
  21.                      (interrupt-set signal/tstp))
  22.      (cond ((%fork) => (lambda (child) (lambda () child))) ; Parent
  23.  
  24.        (else ; Child
  25.         (set-process-group (pid))    ; Put ourselves in our own proc group.
  26.         (if (not (interrupt-handler signal/tstp))    ; If ignoring TSTP,
  27.         (set-interrupt-handler signal/tstp #t))    ; reset to default.
  28.         (set-batch-mode?! #t)            ; Batch mode.
  29.         (lambda () (and (pair? maybe-thunk)        ; Release ^Z & do it.
  30.                 (call-terminally (car maybe-thunk)))))))))
  31.  
  32.  
  33. ;;; Foreground a suspended or running background job.
  34.  
  35. (define (foreground-job proc-group)
  36.   (let ((iport (current-input-port)))
  37.     (cond ((and (not (batch-mode?)) (is-control-tty? iport))
  38.        (dynamic-wind
  39.            (lambda () (set-tty-process-group iport proc-group))
  40.            (lambda ()
  41.          (signal-process-group proc-group signal/cont)    ; You go;
  42.          (wait proc-group wait/stopped-children))    ; I'll wait.
  43.            (lambda ()
  44.                  (with-blocked-interrupts
  45.                  (bitwise-ior (blocked-interrupts)
  46.                       (interrupt-set signal/ttou))
  47.                    (set-tty-process-group iport (process-group))))))
  48.  
  49.       ;; Oops, not really doing job control -- just wait on the process.
  50.       (else (signal-process proc-group signal/cont)        ; You go;
  51.             (wait proc-group wait/stopped-children)))))    ; I'll wait.
  52.  
  53. ;;; Background a suspended job.
  54.  
  55. (define (background-job proc-group)
  56.   (signal-process-group proc-group signal/cont))
  57.  
  58.  
  59. (define-simple-syntax (run . epf)
  60.   (foreground-job (& . epf)))
  61.  
  62. (define-simple-syntax (& . epf)
  63.   (fork-job (lambda () (exec-epf . epf))))
  64.  
  65.  
  66. ;;; Need repl loop that manages some kind of a job table.
  67. ;;; Interactive startup must ignore ^Z.
  68.  
  69. (define *control-tty-fdes* #f)
  70. (define (control-tty-fdes)
  71.   (or *control-tty-fdes*
  72.       (begin (set! *control-tty-fdes*
  73.            (with-errno-handler ((errno data) (else #f))
  74.              (open-fdes "/dev/tty" open/read)))
  75.          *control-tty-fdes*)))
  76.            
  77. (define (is-control-tty? fd/port)
  78.   (with-errno-handler ((errno data) (else #f))    ; False if you fail.
  79.     (tty-process-group fd/port)))        ; Try it.
  80.  
  81.  
  82. ;;; Blocking interrupts
  83. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  84.  
  85. (define (interrupt-set . interrupts)
  86.   (let lp ((ints interrupts) (ans 0))
  87.     (if (pair? ints)
  88.     (lp (cdr ints) (bitwise-ior ans (arithmetic-shift 1 (- (car ints) 1))))
  89.     ans)))
  90.  
  91. (define-simple-syntax (with-blocked-interrupts mask body ...)
  92.   (with-blocked-interrupts* mask (lambda () body ...)))
  93.  
  94. (define (with-blocked-interrupts* mask thunk)
  95.   (let ((old-mask #f))
  96.     (dynamic-wind
  97.         (lambda () (set! old-mask (set-blocked-interrupts mask)))
  98.     thunk
  99.     (lambda () (set-blocked-interrupts old-mask)))))
  100.  
  101. (define (set-blocked-interrupts mask)
  102.   (receive (hi-out lo-out)
  103.       (%set-blocked-interrupts (hi8 mask) (lo24 mask))
  104.     (compose-8/24 hi-out lo-out)))
  105.            
  106.  
  107. (define (blocked-interrupts)
  108.   (call-with-values %blocked-interrupts compose-8/24))
  109.  
  110. (define-foreign %set-blocked-interrupts (set_procmask (fixnum hi)
  111.                               (fixnum lo))
  112.   fixnum  ; hi
  113.   fixnum) ; lo
  114.  
  115. (define-foreign %blocked-interrupts (get_procmask)
  116.   fixnum  ; hi
  117.   fixnum) ; lo
  118.  
  119.  
  120. ;;; Get/Set interrupt handlers
  121. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  122.  
  123. ;;; I'm punting the MASK value for now.
  124. ;;; I'm also punting returning real Scheme handlers for now.
  125.  
  126. (define (set-interrupt-handler interrupt handler)
  127.   (receive (handler flags)         ; Should be (handler mask flags).
  128.            (%set-interrupt-handler interrupt handler 0)
  129.     handler))
  130.  
  131. (define (interrupt-handler interrupt)
  132.   (receive (handler flags) (%interrupt-handler interrupt)
  133.     handler))
  134.  
  135. (define (%interrupt-handler interrupt)
  136.   (receive (err handler flags) (%%interrupt-handler interrupt)
  137.     (if err (errno-error err interrupt-handler interrupt)
  138.     (process-interrupt-handler-retvals handler flags))))
  139.  
  140. ;;; (%set-interrupt-handler interrupt handler [mask flags]) -> [handler mask flags]
  141. ;;; Except no MASK for now.
  142.  
  143. (define (%set-interrupt-handler interrupt handler . args)
  144.   (receive (flags) (parse-optionals args 0)
  145.     (receive (err handler flags)
  146.            (%%set-interrupt-handler interrupt handler flags)
  147.       (if err
  148.       (errno-error err %set-interrupt-handler interrupt handler flags)
  149.       (process-interrupt-handler-retvals handler flags)))))
  150.  
  151. (define-foreign %%set-interrupt-handler (set_int_handler (fixnum signal)
  152.                              (desc handler)
  153.                              (fixnum flags))
  154.   desc        ; #f or errno
  155.   desc        ; handler
  156.   fixnum)    ; flags
  157.  
  158. (define-foreign %%interrupt-handler (get_int_handler (fixnum signal))
  159.   desc        ; #f or errno
  160.   desc        ; handler
  161.   fixnum)    ; flags
  162.  
  163. (define (process-interrupt-handler-retvals handler flags)
  164.   (values (if (integer? handler)
  165.           (error "We don't do Scheme handlers yet.")
  166.           handler)
  167.       flags))
  168.